السلام عليكم و رحمة الله و بركاته

فكرة الكود تقوم على التالي:

1.     يوجد لدينا حركات أصناف في الصفحة الرئيسية و هي صفحة الحركات و اسمهاTotal و اسماء الاصناف موجودة في العمود A .

2.     و يوجد عدد من الاصناف من ضمنها صنف اسمهOrange و له أيضاً صفحة اسمها Orange .

3.     و صنف آخر اسمهApple  و له أيضاً صفحة بنفس الإسم

4.     و نريد كود يقوم بعملcut  لاسم الصنف و من ثم Paste  في الصفحة المرتبطة بإسمه .

و لعمل ذلك قدمت الكود التالي:

	Sub Excel4Us()

	Dim c As Range, LR As Integer, Rng As Range

	Application.EnableEvents = False

	LR = Sheets("Total").Range("a" & Rows.Count).End(xlUp).Row

	Set Rng = Sheets("Total").Range("a2:a" & LR)

	For Each c In Rng

	    Select Case c.Value

	        Case Is = "Apple"

	            c.EntireRow.Cut Sheets("apple").Range("a" & Sheets("apple").Range("a" & Rows.Count).End(xlUp).Row + 1)

	        Case Is = "Orange"

	            c.EntireRow.Cut Sheets("Orange").Range("a" & Sheets("Orange").Range("a" & Rows.Count).End(xlUp).Row + 1)

	    End Select

	Next c

	Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

	Application.EnableEvents = True

	End Sub

__________________

و لكن عند تطبيقه

سنلاحظ البطئ في حركات القص و اللصق

و لذلك قمت بعمل كود اخر رديف له

و هو سريع بإستخدام خاصية الفلترة

و كان هذا هو الكود

	Sub Excel4Us()

	Dim c As Range, LR As Integer, Rng As Range, Product()

	Application.EnableEvents = False

	LR = Sheets("Total").Range("a" & Rows.Count).End(xlUp).Row

	Set Rng = Sheets("Total").Range("a2:d" & LR)

	Product = Array("Apple", "Orange")

	Range("A1:D1").AutoFilter

	With Rng

	    For i = LBound(Product) To UBound(Product)